home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Turnbull China Bikeride
/
Turnbull China Bikeride - Disc 2.iso
/
STUTTGART
/
LANG
/
LISP
/
FOOLS
/
!Fl
/
scm
/
pp
< prev
Wrap
Text File
|
1991-10-16
|
8KB
|
280 lines
;;; pretty print scheme expressions
(provide 'pp)
(in-package 'pp)
; list of printers (initialized at the bottom)
(define *printer-list* nil)
; number of columns to print within
(define *print-columns* 75)
; indentation within special forms
(define *special-indent* 2)
(define (top-level:pretty-print expr . file)
(let ((file (if (null? file) (current-output-port) (car file)))
(expr (if (eq? (object-type expr) 'lambda)
(code-body expr)
expr)))
(print-expr expr 0 file)
(newline file)
#t))
(define (top-level:pp expr)
;; assume symbol == macro-name
(pretty-print (if (symbol? expr) (macro expr) expr)))
;; counters
(define (make-cnt depth) (box (- *print-columns* depth)))
(define cnt-val unbox)
(define cnt-set! set-box!)
(define (cnt-zero? cnt) (<= (cnt-val cnt) 0))
(define (cnt-sub cnt val) (>= (cnt-set! cnt (- (cnt-val cnt) val)) 0))
(define (abbrev expr)
;; check for quote, quasiquote, ... forms
(if (and (pair? expr) (pair? (cdr expr)) (null? (cddr expr)))
(let ((which (memq (car expr)
'(unquote unquote-splicing quote quasiquote))))
(if which (car which)))))
(define (fit? expr cnt)
;; #t if expr will fit within the space provided by cnt
(case (object-type expr)
(symbol (cnt-sub cnt (string-length expr)))
(string (cnt-sub cnt (+ 2 (string-length expr))))
((null true false) (cnt-sub cnt 2))
(pair
(let ((h (car expr))
(t (cdr expr))
(q (abbrev expr)))
(if (and q (pair? t) (null? (cdr t)))
(and (cnt-sub cnt (if (eq? q 'unquote-splicing) 2 1))
(fit? (car t) cnt))
(cond ((null? t)
(and (cnt-sub cnt 2) (fit? h cnt)))
((pair? t)
(and (cnt-sub cnt 1)
(fit? h cnt)
(fit? t cnt)))
(else
(and (cnt-sub cnt 5)
(fit? h cnt)
(fit? t cnt)))))))
(integer (cnt-sub cnt (string-length (integer->string expr #\d))))
(vector
(letrec ((vlen (- (vector-length expr) 1))
(vloop
(lambda (ptr)
(if (< ptr vlen)
(cnt-sub cnt 3)
(and (fit? (vector-ref expr ptr) cnt)
(vloop (+ ptr 1)))))))
(vloop 0)))
(end-of-file (cnt-sub cnt 5))
(character
(cnt-sub cnt
(case expr
(#\newline 9)
(#\tab 5)
(#\space 7)
; assumes no other unprintable characters
(else 3))))
(box
(and (cnt-sub cnt 2)
(fit? (unbox expr) cnt)))
(else
(cnt-sub cnt (string-length (->string expr #t))))))
(define (indent x file)
;; indent by x spaces
(cond ((<= x 0) #t)
((>= x *print-columns*) #t)
((>= x 8) (write-char #\tab file) (indent (- x 8) file))
(else (write-char #\space file) (indent (- x 1) file))))
(define (print-expr expr depth file)
(if (and (pair? expr) (not (fit? expr (make-cnt depth))))
(if (and (not (pair? (car expr))) (list? expr))
(let ((printer (assq (car expr) *printer-list*)))
(if printer
((cdr printer) expr depth file)
(print-op expr depth file)))
(print-list expr depth file))
(write expr file)))
(define (print-op expr depth file)
(write-char #\( file)
(print-expr (car expr) depth file)
(set! depth (+ depth 2 (string-length (car expr))))
(when (pair? (cdr expr))
(write-char #\space file)
(print-expr (cadr expr) depth file)
(for-each (lambda (expr)
(newline file)
(indent depth file)
(print-expr expr depth file))
(cddr expr)))
(write-char #\) file))
(define (print-list lst depth file)
(letrec ((loop
(lambda (first? lst)
(cond ((null? lst) #t)
((not (pair? lst))
(fdisplay file " . ")
(print-expr lst (+ depth 3) file))
(else
(unless first?
(newline file)
(indent depth file))
(print-expr (car lst) depth file)
(loop #f (cdr lst)))))))
(write-char #\( file)
(set! depth (+ depth 1))
(loop #t lst)
(write-char #\) file)))
(define (print-clause clause depth file)
; generic clause/binding printer
(if (fit? clause (make-cnt depth))
(write clause file)
(begin
(write-char #\( file)
(set! depth (+ depth 1))
(print-expr (car clause) depth file)
(for-each (lambda (expr)
(newline file)
(indent depth file)
(print-expr expr depth file))
(cdr clause))
(write-char #\) file))))
(define (print-let expr depth file)
; print (let[rec] [name] bindings . body)
(let ((cdepth (+ depth 3 (string-length (car expr))))
(bindings (cadr expr))
(body (cddr expr))
(first? #t))
(fdisplay file "(" (car expr))
(if (symbol? bindings) ; named let
(begin (fdisplay file " " bindings)
(set! cdepth (+ cdepth 1 (string-length bindings)))
(set! bindings (caddr expr))
(set! body (cdr body))))
(display " (" file)
(for-each (lambda (clause)
(if first?
(set! first? #f)
(begin (newline file) (indent cdepth file)))
(print-clause clause cdepth file))
bindings)
(write-char #\) file)
(set! depth (+ depth *special-indent*))
(for-each (lambda (expr)
(newline file) (indent depth file)
(print-expr expr depth file))
body)
(write-char #\) file)))
(define (print-cond expr depth file)
; print (cond . clauses)
(let ((first? #t))
(write-char #\( file)
(display (car expr) file)
(write-char #\space file)
(set! depth (+ depth 2 (string-length (car expr))))
(for-each (lambda (clause)
(if first?
(set! first? #f)
(begin (newline file) (indent depth file)))
(print-clause clause depth file))
(cdr expr))
(write-char #\) file)))
(define (print-case expr depth file)
(write-char #\( file)
(display (car expr) file)
(write-char #\space file)
(display (cadr expr) file)
(set! depth (+ depth *special-indent*))
(for-each (lambda (clause)
(newline file)
(indent depth file)
(print-clause clause depth file))
(cddr expr))
(write-char #\) file))
(define (print-sform expr depth file)
; print (sform arg . body)
(fdisplay file #\( (car expr) #\space (cadr expr))
(set! depth (+ depth *special-indent*))
(for-each (lambda (arg)
(newline file)
(indent depth file)
(print-expr arg depth file))
(cddr expr))
(write-char #\) file))
(define (print-sform0 expr depth file)
; print (sform . body)
(fdisplay file #\( (car expr))
(set! depth (+ depth *special-indent*))
(for-each (lambda (arg)
(newline file)
(indent depth file)
(print-expr arg depth file))
(cdr expr))
(write-char #\) file))
(define (print-quote expr depth file)
; print (quote arg)
(if (and (pair? (cdr expr)) (null? (cddr expr)))
(begin
(write-char #\' file)
(print-expr (cadr expr) (+ depth 1) file))
(write expr file)))
(define (print-quasi expr depth file)
; print (quasiquote|unquote|unquote-splicing arg)
(let ((which (abbrev expr)))
(if which
(let ((arg (cadr expr)))
(case which
(quasiquote (write-char #\` file))
(unquote (write-char #\, file))
(else (display ",@" file)))
(if (pair? arg)
(print-list arg
(+ depth (if (eq? which 'unquote-splicing) 2 1))
file)
(write arg file)))
(print-op expr depth file))))
(define (printer-add form printer)
; add pretty printers
(set! *printer-list* (cons (cons form printer) *printer-list*))
#t)
(printer-add 'lambda print-sform)
(printer-add 'define print-sform)
(printer-add 'define-macro print-sform)
(printer-add 'extend-syntax print-sform)
(printer-add 'cond print-cond)
(printer-add 'let print-let)
(printer-add 'letrec print-let)
(printer-add 'let* print-let)
(printer-add 'do print-let)
(printer-add 'quote print-quote)
(printer-add 'quasiquote print-quasi)
(printer-add 'unquote print-quasi)
(printer-add 'unquote-splicing print-quasi)
(printer-add 'call-with-current-continuation print-sform0)
(printer-add 'call/cc print-sform0)
(printer-add 'case print-case)
(printer-add 'record-case print-case)
(printer-add 'when print-sform)
(printer-add 'unless print-sform)
(printer-add 'while print-sform)